home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / ZVAL LISP / ZVAL.LISP < prev   
Encoding:
Text File  |  1990-08-22  |  24.5 KB  |  625 lines  |  [TEXT/ttxt]
  1. ;;  This is an implementation of ZVAL for ALLEGRO.
  2. ;;
  3. ;;   ZVAL makes it easy to try out code as you write it, and to debug 
  4. ;; functions by evaluating them line by line in the editor.
  5. ;;   You assign sample values to the parameters of a function and then 
  6. ;; evaluate individual lines in the function in terms of these sample values. 
  7. ;;
  8. ;;  There are 3 basic commands:
  9. ;; (1) super-T: Evaluate expression.
  10. ;;              The expression to the right of the cursor is evaluated.
  11. ;; (2) super-B: Evaluate LET binding.
  12. ;;              The LET expression to the right of the cursor is evaluated.
  13. ;;              e.g. (mystring (subseq "something" 0 4)) is evaluated as
  14. ;;                   (setq mystring (subseq "something" 0 4)).
  15. ;;              This means that instead of BINDing the value of mystring, ZVAL
  16. ;;              SETs the value at the top level.
  17. ;; (3) super-L: Evaluate FOR or WITH expression in a LOOP macro.
  18. ;;
  19. ;;  The names are historical -- they name the keys the commands were assigned to 
  20. ;; on Lisp machines.
  21. ;;  In Allegro, the commands are assigned to function keys on the extended keyboard.
  22. ;;  The assignments are made at the end of this file, so you can change them
  23. ;; to other keys if you wish.
  24. ;; super-T is assigned to F5.
  25. ;; super-B is assigned to F6.
  26. ;; super-L is assigned to F7.
  27. ;;
  28. ;;  Holding down the Control key does Initial assignments:
  29. ;;  To assign a value of your choice to a variable, hold down the Control key while
  30. ;; using the super-T command. You will be prompted for the value in the Lisp Listener.
  31. ;;  The first time through a LOOP, hold down the Control key while using the super-L
  32. ;; command. This will assign initial values to variables, and also prepare future
  33. ;; values where appropriate.
  34. ;;
  35. ;;  Holding down the Option key does Multiple assignments:
  36. ;; All of the LET assignments (option-super-B), 
  37. ;; all of the expressions in the current form (option-super-T), 
  38. ;; or all of the FOR and WITH assignments (option-super-L)
  39. ;; will be done in sequence.
  40. ;;
  41. ;;
  42. ;;  THE TYPICAL WAY TO USE ZVAL IS TO:
  43. ;;  1) Use control-super-T to assign initial values to the parameters of a function.
  44. ;;  2) Use meta-super-B to set all of the LET bindings.
  45. ;;  3) Then, use super-T to step through the body of the function.
  46. ;;  4) Use super-L whenever you encounter a LOOP macro.
  47. ;;
  48. ;;
  49. ;;
  50. ;;  ADDITIONAL FEATURES:
  51. ;;   (1). The F8 key is assigned to Set Variable To Yank. This is like control-super-T, except
  52. ;; that instead of prompting the user for the value, the top item from the kill ring
  53. ;; is yanked and evaluated.
  54. ;;
  55. ;;    (2). There is a kludged version of GrabArgs assigned to F9.
  56. ;;  Grabargs is used when one of your functions BREAKs.  In the editor, put your cursor 
  57. ;;  on the first argument in the  defun of the function in the BREAK (that's the kludgey 
  58. ;;  part).  When you press F9, all of the arguments to the function will be SETQ'd to
  59. ;;  their values in the BREAK.  You can then use ZVAL to step through the body of the
  60. ;;  function and see where it fails.
  61. ;;  For example, if you have a function
  62. ;;  (defun TEST.FOR.SIMILAR.OBJECTS (object1 object2) ...
  63. ;;  which breaks, put the cursor just before the "o" in "object1" and press F9. 
  64. ;;  Object1 and object2 will be setq'd to the values which caused the break.  
  65. ;;  Using the other ZVAL commands to step through TEST.FOR.SIMILAR.OBJECTS, 
  66. ;;  you will see which line in the function causes the break.
  67.  
  68.  
  69. (defvar *zval.window*)
  70. (defvar *zval-alist* nil)
  71. (defvar *tab.space* "  ")
  72. (setf (subseq *tab.space* 1 2) (string #\Tab))
  73. (defvar *tab.space.return* "   ")
  74. (setf (subseq *tab.space.return* 1 2) (string #\Tab))
  75. (setf (subseq *tab.space.return* 2 3) (string #\Return))
  76.  
  77.  
  78. (defun CREATE.ZVAL.WINDOW ()
  79.   (setq *zval.window*
  80.         (oneof *fred-window*
  81.                :window-position (make-point 10 50)
  82.                :window-size (make-point 200 100)
  83.                :window-title "ZVAL"
  84.                :scratch-p t))
  85.   (ask *zval.window* (ccl::window-hide))
  86.   )
  87.  
  88. (defun zval-let-binding ()
  89.   "The equivalent of super-B"
  90.   (let* ((window (first (windows *fred-window*)))
  91.          (buffer (ask window (window-buffer)))
  92.          (mark (ask window (window-cursor-mark)))
  93.          (zval.window *zval.window*)
  94.          (zval.buffer (ask zval.window (window-buffer)))
  95.          zval.mark first.char
  96.          )
  97.     (skip-whitespace buffer mark)
  98.     (setq first.char (ccl::buffer-char buffer mark))
  99.     (ask window (ccl::ed-select-current-sexp))
  100.     (ask window (ccl::ed-copy-region-as-kill))
  101.     (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  102.     (skip-whitespace buffer mark)
  103.     (when (eql #\; (ccl::buffer-char buffer mark))
  104.       (loop for char = (ccl::buffer-char buffer mark)
  105.             while (eql #\; char)
  106.             do 
  107.             (ask window (ccl::ed-next-line))
  108.             (ask window (ccl::ed-beginning-of-line))
  109.             (skip-whitespace buffer mark)
  110.             )
  111.       )
  112.     (if (eql #\) (ccl::buffer-char buffer mark))
  113.       (set-mark mark (ccl::buffer-char-pos buffer #\( :start mark)))     
  114.     (cond 
  115.      ((eql first.char #\()
  116.       (ask zval.window (ccl::ed-yank))
  117.       (ask zval.window (ccl::ed-backward-sexp))
  118.       (ask zval.window (ccl::ed-forward-char))
  119.       (setq zval.mark (ask zval.window (window-cursor-mark)))
  120.       (ccl::buffer-insert zval.buffer "setq " zval.mark))
  121.      (t
  122.       (setq zval.mark (ask zval.window (window-cursor-mark)))
  123.       (ccl::buffer-insert zval.buffer "(setq " zval.mark)
  124.       (ask zval.window (ccl::ed-yank))
  125.       (ccl::buffer-insert zval.buffer " nil)" zval.mark))
  126.      )
  127.     (ask zval.window (ccl::ed-beginning-of-line))     
  128.     (ask zval.window (ccl::ed-forward-sexp))     
  129.     (ask zval.window (ccl::ed-eval-or-compile-current-sexp))
  130.     (ccl::buffer-insert zval.buffer "
  131. " zval.mark)
  132.     ))
  133.  
  134. (defun zval-let-bindings ()
  135.   "Repeated super-Bs until the end of the let bindings is reached."
  136.   (let* ((window (first (windows *fred-window*)))
  137.          (buffer (ask window (window-buffer)))
  138.          (mark (ask window (window-cursor-mark)))
  139.          (zval.window *zval.window*)
  140.          (zval.buffer (ask zval.window (window-buffer)))
  141.          zval.mark first.char
  142.          )
  143.     (loop 
  144.       do
  145.       (skip-whitespace buffer mark)
  146.       (setq first.char (ccl::buffer-char buffer mark))
  147.       (ask window (ccl::ed-select-current-sexp))
  148.       (ask window (ccl::ed-copy-region-as-kill))
  149.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  150.       (skip-whitespace buffer mark)
  151.     (when (eql #\; (ccl::buffer-char buffer mark))
  152.       (loop for char = (ccl::buffer-char buffer mark)
  153.             while (eql #\; char)
  154.             do 
  155.             (ask window (ccl::ed-next-line))
  156.             (ask window (ccl::ed-beginning-of-line))
  157.             (skip-whitespace buffer mark)
  158.             )
  159.       )
  160.       (cond 
  161.        ((eql first.char #\()
  162.         (ask zval.window (ccl::ed-yank))
  163.         (ask zval.window (ccl::ed-backward-sexp))
  164.         (ask zval.window (ccl::ed-forward-char))
  165.         (setq zval.mark (ask zval.window (window-cursor-mark)))
  166.         (ccl::buffer-insert zval.buffer "setq " zval.mark))
  167.        (t
  168.         (setq zval.mark (ask zval.window (window-cursor-mark)))
  169.         (ccl::buffer-insert zval.buffer "(setq " zval.mark)
  170.         (ask zval.window (ccl::ed-yank))
  171.         (ccl::buffer-insert zval.buffer " nil)" zval.mark))
  172.        )
  173.       (ask zval.window (ccl::ed-beginning-of-line))     
  174.       (ask zval.window (ccl::ed-forward-sexp))     
  175.       (ask zval.window (ccl::ed-eval-or-compile-current-sexp))
  176.       (ccl::buffer-insert zval.buffer "
  177. " zval.mark)
  178.       until (eql #\) (ccl::buffer-char buffer mark))
  179.       )
  180.     (set-mark mark (ccl::buffer-char-pos buffer #\( :start mark))      
  181.     ))
  182.  
  183. (defun zval-setq ()
  184.   "super-1 super-T: set the variable to the right of the cursor
  185.    to the value of an expression entered in the listener"
  186.   (let* ((window (first (windows *fred-window*)))
  187.          (buffer (ask window (window-buffer)))
  188.          (mark (ask window (window-cursor-mark)))
  189.          (l-window (listener-window))
  190.          (l-buffer (ask l-window (window-buffer)))
  191.          var.name
  192.          )
  193.     (setq var.name (ccl::buffer-current-sexp buffer mark))
  194.     (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  195.     (when (eql #\Space (ccl::buffer-char buffer mark))
  196.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  197.       (set-mark mark (ccl::buffer-bwd-sexp buffer mark)))
  198.     (ccl::buffer-insert l-buffer (format nil "(setq ~A " var.name))
  199.     (ask l-window (window-update))
  200.     (ask l-window (window-select))
  201.     ))
  202.  
  203. (defun zval-setq-to-yank ()
  204.   "Modified super-1 super-T: set the variable to the right of the cursor
  205.    to the value of the expression in the kill ring."
  206.   (let* ((window (first (windows *fred-window*)))
  207.          (buffer (ask window (window-buffer)))
  208.          (mark (ask window (window-cursor-mark)))
  209.          var.name value
  210.          )
  211.     (setq var.name (ccl::buffer-current-sexp buffer mark))
  212.     (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  213.     (when (eql #\Space (ccl::buffer-char buffer mark))
  214.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  215.       (set-mark mark (ccl::buffer-bwd-sexp buffer mark)))
  216.     (setq value (eval (get-item-from-kill-ring)))
  217.     (set var.name value)
  218.     (show-user "Setting ~A to ~A." var.name value)
  219.     (ask (listener-window) (window-update))
  220.     ))
  221.  
  222. (defun zval-eval ()
  223.   "super-T: evaluate the expression to the right of the cursor, then move
  224.    cursor to next expression."
  225.   (let* ((window (first (windows *fred-window*)))
  226.          (buffer (ask window (window-buffer)))
  227.          (mark (ask window (window-cursor-mark)))
  228.          )
  229.     (skip-whitespace buffer mark)
  230.     (when (member (ccl::buffer-current-sexp buffer mark) 
  231.                 '(if else while until always never finally do collect append nconc))
  232.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  233.       (skip-whitespace buffer mark)
  234.       )
  235.     (ask window (ccl::ed-eval-or-compile-current-sexp))
  236.     (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  237.     (skip-whitespace buffer mark)
  238.     ;; Skip over &optional and &rest in arglist
  239.     (when (eql #\& (ccl::buffer-char buffer mark))
  240.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  241.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  242.       (set-mark mark (ccl::buffer-bwd-sexp buffer mark)))
  243.     ))
  244.  
  245. (defun zval-evals ()
  246.   "Repeated super-Ts until the end of the body is reached."
  247.   (let* ((window (first (windows *fred-window*)))
  248.          (buffer (ask window (window-buffer)))
  249.          (mark (ask window (window-cursor-mark)))
  250.          )
  251.     (loop 
  252.       do
  253.       (skip-whitespace buffer mark)
  254.       (when (member (ccl::buffer-current-sexp buffer mark) 
  255.                     '(if else while until finally do collect append nconc))
  256.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  257.         (skip-whitespace buffer mark)
  258.         )
  259.       ;; Skip over &optional and &rest in arglist
  260.       (when (eql #\& (ccl::buffer-char buffer mark))
  261.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  262.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  263.         (set-mark mark (ccl::buffer-bwd-sexp buffer mark)))
  264.       (ask window (ccl::ed-eval-or-compile-current-sexp))
  265.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  266.       (skip-whitespace buffer mark)
  267.       until (eql #\) (ccl::buffer-char buffer mark))
  268.       )
  269.     ))
  270.  
  271. (defun zval-initial-loop-binding ()
  272.   "super-1 super-L.  Get the first value for a loop variable."
  273.   (let* ((window (first (windows *fred-window*)))
  274.          (buffer (ask window (window-buffer)))
  275.          (mark (ask window (window-cursor-mark)))
  276.          sexp var.name var.val var.vals var.end.val
  277.          (l-window (listener-window))
  278.          )
  279.     (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  280.     (setq sexp (ccl::buffer-current-sexp buffer mark))
  281.     (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  282.     (cond 
  283.      ((eql sexp 'for)  ;; FOR X ...
  284.       (setq var.name (ccl::buffer-current-sexp buffer mark))
  285.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  286.       (setq sexp (ccl::buffer-current-sexp buffer mark))
  287.       (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  288.       (cond 
  289.        ((eql sexp '=)   ;; FOR X = Y,   FOR X = Y THEN Z
  290.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  291.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  292.         (setq var.val (eval (ccl::buffer-current-sexp buffer mark)))
  293.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  294.         (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  295.         (set var.name var.val)
  296.         (setq sexp (ccl::buffer-current-sexp buffer mark))
  297.         (when (eql sexp 'then)
  298.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  299.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  300.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  301.           (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  302.           )
  303.         (show-user "~A = ~A" var.name var.val) 
  304.         )
  305.        ((eql sexp 'in)   ;; FOR X IN XLIST
  306.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  307.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  308.         (setq var.vals (eval (ccl::buffer-current-sexp buffer mark)))
  309.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  310.         (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  311.         (cond ((eql 0 (length var.vals)) 
  312.                (ed-beep)
  313.                (show-user "Null sequence for ~A" var.name))
  314.               (t
  315.                (set var.name (first var.vals))
  316.                (setq *zval-alist* 
  317.                      (acons var.name (cdr var.vals) *zval-alist*))
  318.                (show-user "~A = ~A   THEN: ~A"
  319.                           var.name (first var.vals) (cdr var.vals)))
  320.               )
  321.         )
  322.        ((eql sexp 'from)   ;; FOR X FROM 1,   FOR X FROM 1 TO 3
  323.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  324.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  325.         (setq var.val (eval (ccl::buffer-current-sexp buffer mark)))
  326.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  327.         (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  328.         (set var.name var.val)
  329.         (setq sexp (ccl::buffer-current-sexp buffer mark))
  330.         (setq var.end.val nil)
  331.         (when (eql sexp 'to)
  332.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  333.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  334.           (setq var.end.val (eval (ccl::buffer-current-sexp buffer mark)))
  335.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  336.           (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  337.           )
  338.         (setq var.vals (cdr (integer-list var.val var.end.val 10)))
  339.         (setq *zval-alist* (acons var.name var.vals *zval-alist*))
  340.         (show-user "~A = ~A   THEN: ~A" var.name var.val var.vals)
  341.         )
  342.        ))
  343.      ((eql sexp 'with)  ;; WITH X ...
  344.       (setq var.name (ccl::buffer-current-sexp buffer mark))
  345.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  346.       (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  347.       (setq sexp (ccl::buffer-current-sexp buffer mark))
  348.       (setq var.val nil)
  349.       (when 
  350.         (eql sexp '=)   ;; WITH X = Y
  351.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  352.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  353.         (setq var.val (eval (ccl::buffer-current-sexp buffer mark)))
  354.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  355.         (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  356.         )
  357.       (set var.name var.val)
  358.       (show-user "~A = ~A" var.name var.val)
  359.       )
  360.      )
  361.     (ask l-window (window-update))
  362.     ))
  363.  
  364. (defun zval-loop-binding ()
  365.   "super-L.  Get the next value for a loop variable."
  366.   (let* ((window (first (windows *fred-window*)))
  367.          (buffer (ask window (window-buffer)))
  368.          (mark (ask window (window-cursor-mark)))
  369.          sexp var.name var.val
  370.          first.val pair
  371.          )
  372.     (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  373.     (setq sexp (ccl::buffer-current-sexp buffer mark))
  374.     (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  375.     (cond 
  376.      ((eql sexp 'for)  ;; FOR X ...
  377.       (setq var.name (ccl::buffer-current-sexp buffer mark))
  378.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  379.       (setq sexp (ccl::buffer-current-sexp buffer mark))
  380.       (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  381.       (cond 
  382.        ((eql sexp '=)   ;; FOR X = Y,   FOR X = Y THEN Z
  383.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  384.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  385.         (setq first.val (eval (ccl::buffer-current-sexp buffer mark)))
  386.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  387.         (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  388.         (setq sexp (ccl::buffer-current-sexp buffer mark))
  389.         (cond 
  390.          ((eql sexp 'then)
  391.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  392.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  393.           (setq var.val (eval (ccl::buffer-current-sexp buffer mark)))
  394.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  395.           (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  396.           )
  397.          (t (setq var.val first.val))
  398.          )
  399.         (set var.name var.val)
  400.         (show-user "~A = ~A" var.name var.val) 
  401.         )
  402.        ((eql sexp 'in)   ;; FOR X IN XLIST
  403.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  404.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  405.         (setq pair (assoc var.name *zval-alist*))
  406.         (cond ((> (length (cdr pair)) 0) 
  407.                (setq var.val (first (cdr pair)))
  408.                (set var.name var.val)
  409.                (show-user "~A = ~A   THEN: ~A" 
  410.                           var.name var.val (cddr pair)))
  411.               (t (ed-beep)
  412.                  (show-user "Sequence terminated for ~A" var.name))
  413.               )
  414.         (if pair (rplacd pair (cddr pair)))
  415.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  416.         (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  417.         )
  418.        ((eql sexp 'from)   ;; FOR X FROM 1,   FOR X FROM 1 TO 3
  419.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  420.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  421.         (setq pair (assoc var.name *zval-alist*))
  422.         (cond ((> (length (cdr pair)) 0) 
  423.                (setq var.val (first (cdr pair)))
  424.                (set var.name var.val)
  425.                (show-user "~A = ~A   THEN: ~A" 
  426.                           var.name var.val (cddr pair)))
  427.               (t (ed-beep)
  428.                  (show-user "Sequence terminated for ~A" var.name))
  429.               )
  430.         (if pair (rplacd pair (cddr pair)))
  431.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  432.         (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  433.         (setq sexp (ccl::buffer-current-sexp buffer mark))
  434.         (when (eql sexp 'to)
  435.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  436.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  437.           (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  438.           (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  439.           )
  440.         )
  441.        ))
  442.      ((eql sexp 'with)  ;; WITH X ...
  443.       (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  444.       (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  445.       (setq sexp (ccl::buffer-current-sexp buffer mark))
  446.       (when 
  447.         (eql sexp '=)   ;; WITH X = Y
  448.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  449.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  450.         (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  451.         (set-mark mark (ccl::buffer-bwd-sexp buffer mark))
  452.         )
  453.       )
  454.      )
  455.     (ask (listener-window) (window-update))
  456.     ))
  457.  
  458. (defun zval-initial-loop-bindings ()
  459.   "Multiple 'FOR' and 'WITH' intial bindings"
  460.   (let* ((window (first (windows *fred-window*)))
  461.          (buffer (ask window (window-buffer)))
  462.          (mark (ask window (window-cursor-mark)))
  463.          )
  464.     (loop for keyword = (ccl::buffer-current-sexp buffer mark)
  465.           while (member keyword '(for with))
  466.           do (zval-initial-loop-binding)
  467.           )
  468.     ))
  469.     
  470. (defun zval-loop-bindings ()
  471.   "Multiple 'FOR' and 'WITH' bindings"
  472.   (let* ((window (first (windows *fred-window*)))
  473.          (buffer (ask window (window-buffer)))
  474.          (mark (ask window (window-cursor-mark)))
  475.          )
  476.     (loop for keyword = (ccl::buffer-current-sexp buffer mark)
  477.           while (member keyword '(for with))
  478.           do (zval-loop-binding)
  479.           )
  480.     ))
  481.  
  482. (defun ga ()
  483.   "Kludged because it's hard to get hold of backtrace info.
  484.    Put the cursor on the first arg in the defun's arglist."
  485.   (declare (special val0 val1 val2 val3 val4 val5 val6 val7 val8 val9))
  486.   (let* ((window (first (windows *fred-window*)))
  487.          (buffer (ask window (window-buffer)))
  488.          (mark (ask window (window-cursor-mark)))
  489.          )
  490.     (setq val0 (local 0))
  491.     (setq val1 (local 1))
  492.     (setq val2 (local 2))
  493.     (setq val3 (local 3))
  494.     (setq val4 (local 4))
  495.     (setq val5 (local 5))
  496.     (setq val6 (local 6))
  497.     (setq val7 (local 7))
  498.     (setq val8 (local 8))
  499.     (setq val9 (local 9))
  500.   (loop for count from 0 to 9
  501.         with arg.name 
  502.         do (setq arg.name (NEXT.ARG.NAME buffer mark))
  503.         while arg.name
  504.         do (set arg.name (symbol-value (name 'val count)))
  505.         (show-user "~A = ~A" arg.name (symbol-value (name 'val count)))
  506.         )
  507.     (ask (listener-window) (window-update))
  508.   ))
  509.  
  510. ;;; Auxiliary functions
  511.  
  512. (defun next.arg.name (buffer mark)
  513.   (let (arg.name
  514.         )
  515.     (loop 
  516.       do (set-mark mark (ccl::buffer-fwd-sexp buffer mark))
  517.       (setq arg.name (ccl::buffer-current-sexp buffer mark))
  518.       if (not (symbolp arg.name))
  519.       return nil
  520.       else if (not (member (subseq (string arg.name) 0 1) '("&" ":") :test 'string-equal))
  521.            return arg.name
  522.         )
  523. ))
  524.  
  525. (defun skip-whitespace (buffer mark)
  526.   (if (member (ccl::buffer-char buffer mark) '(#\Space  #\Tab #\Return))
  527.     (set-mark mark (ccl::buffer-not-char-pos buffer *tab.space.return*
  528.                                              :start mark)))
  529.   )
  530.  
  531.     
  532. (defun integer-list (start.num end.num &optional max.size)
  533.   "(integer-list 3 7) returns (3 4 5 6 7). If max.size is 3,
  534.    returns (3 4 5). If end.num is nil, returns list of size max.size or 10"
  535.   (if (null end.num)
  536.     (setq end.num (+ start.num (or max.size 10))))
  537.   (when (>= end.num start.num)
  538.     (loop for integer from start.num to end.num
  539.           for count from 1
  540.           until (and max.size (> count max.size))
  541.           collect integer)
  542.     )
  543.   )
  544.  
  545. (defun listener-window ()
  546.   "Find the lisp listener window"
  547.   (let* ((windows (windows *fred-window*))
  548.          listener
  549.          )
  550.     (setq listener 
  551.           (loop for window in windows
  552.                 for name = (ask window ccl::object-name)
  553.                 if (string-equal name "Listener")
  554.                 return window))
  555.     ))
  556.  
  557. (defun show-user (format-string &rest format-args)
  558.   "Formats the string into the lisp-listener"
  559.   (let* ((l-window (listener-window))
  560.          (l-buffer (ask l-window (window-buffer)))
  561.          (l-window-start-mark (ask l-window (ccl::window-start-mark)))
  562.          )
  563.     (ccl::buffer-insert l-buffer 
  564.                         (apply 'format nil 
  565.                                (concatenate 'string format-string "~%") 
  566.                                format-args)
  567.                         (buffer-line-start l-buffer))
  568.     (set-mark l-window-start-mark                                       
  569.               (ccl::buffer-line-start l-window-start-mark nil 1))
  570.     
  571.     ))
  572.  
  573. (defun my-pop-string-from-kill-ring ()
  574.   (let ((string-to-pop (caar ccl::*killed-string-yank-pointer*)))
  575.     (rplaca ccl::*killed-string-yank-pointer* (cons "" nil))
  576.     (setq ccl::*killed-string-yank-pointer*
  577.           (cdr ccl::*killed-string-yank-pointer*))
  578.     string-to-pop))
  579.  
  580. (defun get-item-from-kill-ring ()
  581.   (let* ((zval.window *zval.window*)
  582.          (zval.buffer (ask zval.window (window-buffer)))
  583.          zval.mark
  584.          )
  585.     (ask zval.window (select-all))
  586.     (ask zval.window (ccl::ed-yank))
  587.     (ask zval.window (select-all))
  588.     (ccl::buffer-current-sexp zval.buffer zval.mark)    
  589.     ))
  590.  
  591.  
  592.   
  593.  
  594. (create.zval.window)
  595.  
  596. ;;  KEY ASSIGNMENTS
  597. (def-fred-command (:function #\5) zval-let-binding)
  598. (def-fred-command (:function :meta #\5) zval-let-bindings)
  599. (def-fred-command (:function #\6) zval-eval)
  600. (def-fred-command (:function :meta #\6) zval-evals)
  601. (def-fred-command (:function :control #\6) zval-setq)
  602. (def-fred-command (:function #\7) zval-loop-binding)
  603. (def-fred-command (:function :meta #\7) zval-loop-bindings)
  604. (def-fred-command (:function :control #\7) zval-initial-loop-binding)
  605. (def-fred-command (:function :control :meta #\7) zval-initial-loop-bindings)
  606. (def-fred-command (:function #\8) zval-setq-to-yank)
  607. (def-fred-command (:function #\9) ga)
  608.  
  609.  
  610. #|
  611. (defun tryloops ()
  612.   (let* ((a '(my this is))
  613.          (b 5)
  614.          )
  615.     (loop for x = (first a)
  616.           for x1 = 12 then b
  617.           for y in a
  618.           for z from 7
  619.           for w from 9 to 12
  620.           with c1
  621.           with c2 = 66
  622.           do (setq x 100)
  623.           )))
  624. |#
  625.